home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / lsp / describe.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  16KB  |  425 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;    describe.lsp
  6. ;;;;
  7. ;;;;                           DESCRIBE and INSPECT
  8.  
  9.  
  10. (in-package 'lisp)
  11.  
  12. (export '(describe inspect))
  13.  
  14.  
  15. (in-package 'system)
  16.  
  17.  
  18. (proclaim '(optimize (safety 2) (space 3)))
  19.  
  20.  
  21. (defvar *inspect-level* 0)
  22. (defvar *inspect-history* nil)
  23. (defvar *inspect-mode* nil)
  24.  
  25. (defvar *old-print-level* nil)
  26. (defvar *old-print-length* nil)
  27.  
  28.  
  29. (defun inspect-read-line ()
  30.   (do ((char (read-char *query-io*) (read-char *query-io*)))
  31.       ((or (char= char #\Newline) (char= char #\Return)))))
  32.  
  33. (defun read-inspect-command (label object allow-recursive)
  34.   (unless *inspect-mode*
  35.     (inspect-indent-1)
  36.     (if allow-recursive
  37.         (progn (princ label) (inspect-object object))
  38.         (format t label object))
  39.     (return-from read-inspect-command nil))
  40.   (loop
  41.     (inspect-indent-1)
  42.     (if allow-recursive
  43.         (progn (princ label)
  44.                (inspect-indent)
  45.                (prin1 object))
  46.         (format t label object))
  47.     (write-char #\Space)
  48.     (force-output)
  49.     (case (do ((char (read-char *query-io*) (read-char *query-io*)))
  50.               ((and (char/= char #\Space) (char/= #\Tab)) char))
  51.       ((#\Newline #\Return)
  52.        (when allow-recursive (inspect-object object))
  53.        (return nil))
  54.       ((#\n #\N)
  55.        (inspect-read-line)
  56.        (when allow-recursive (inspect-object object))
  57.        (return nil))
  58.       ((#\s #\S) (inspect-read-line) (return nil))
  59.       ((#\p #\P)
  60.        (inspect-read-line)
  61.        (let ((*print-pretty* t) (*print-level* nil) (*print-length* nil))
  62.             (prin1 object)
  63.             (terpri)))
  64.       ((#\a #\A) (inspect-read-line) (throw 'abort-inspect nil))
  65.       ((#\u #\U)
  66.        (return (values t (prog1
  67.                           (eval (read-preserving-whitespace *query-io*))
  68.                           (inspect-read-line)))))
  69.       ((#\e #\E)
  70.        (dolist (x (multiple-value-list
  71.                    (multiple-value-prog1
  72.                     (eval (read-preserving-whitespace *query-io*))
  73.                     (inspect-read-line))))
  74.                (write x
  75.                       :level *old-print-level*
  76.                       :length *old-print-length*)
  77.                (terpri)))       
  78.       ((#\q #\Q) (inspect-read-line) (throw 'quit-inspect nil))
  79.       (t (inspect-read-line)
  80.          (terpri)
  81.          (format t
  82.                  "Inspect commands:~%~
  83.         n (or N or Newline):    inspects the field (recursively).~%~
  84.         s (or S):        skips the field.~%~
  85.         p (or P):        pretty-prints the field.~%~
  86.         a (or A):        aborts the inspection ~
  87.                     of the rest of the fields.~%~
  88.         u (or U) form:        updates the field ~
  89.                     with the value of the form.~%~
  90.         e (or E) form:        evaluates and prints the form.~%~
  91.         q (or Q):        quits the inspection.~%~
  92.         ?:            prints this.~%~%")))))
  93.  
  94. (defmacro inspect-recursively (label object &optional place)
  95.   (if place
  96.       `(multiple-value-bind (update-flag new-value)
  97.             (read-inspect-command ,label ,object t)
  98.          (when update-flag (setf ,place new-value)))
  99.       `(when (read-inspect-command ,label ,object t)
  100.              (princ "Not updated.")
  101.              (terpri))))
  102.  
  103. (defmacro inspect-print (label object &optional place)
  104.   (if place
  105.       `(multiple-value-bind (update-flag new-value)
  106.            (read-inspect-command ,label ,object nil)
  107.          (when update-flag (setf ,place new-value)))
  108.       `(when (read-inspect-command ,label ,object nil)
  109.              (princ "Not updated.")
  110.              (terpri))))
  111.           
  112. (defun inspect-indent ()
  113.   (fresh-line)
  114.   (format t "~V@T"
  115.           (* 4 (if (< *inspect-level* 8) *inspect-level* 8))))
  116.  
  117. (defun inspect-indent-1 ()
  118.   (fresh-line)
  119.   (format t "~V@T"
  120.           (- (* 4 (if (< *inspect-level* 8) *inspect-level* 8)) 3)))
  121.  
  122.  
  123. (defun inspect-symbol (symbol)
  124.   (let ((p (symbol-package symbol)))
  125.     (cond ((null p)
  126.            (format t "~:@(~S~) - uninterned symbol" symbol))
  127.           ((eq p (find-package "KEYWORD"))
  128.            (format t "~:@(~S~) - keyword" symbol))
  129.           (t
  130.            (format t "~:@(~S~) - ~:[internal~;external~] symbol in ~A package"
  131.                    symbol
  132.                    (multiple-value-bind (b f)
  133.                                         (find-symbol (symbol-name symbol) p)
  134.                      (declare (ignore b))
  135.                      (eq f :external))
  136.                    (package-name p)))))
  137.  
  138.   (when (boundp symbol)
  139.         (if *inspect-mode*
  140.             (inspect-recursively "value:"
  141.                                  (symbol-value symbol)
  142.                                  (symbol-value symbol))
  143.             (inspect-print "value:~%   ~S"
  144.                            (symbol-value symbol)
  145.                            (symbol-value symbol))))
  146.  
  147.   (do ((pl (symbol-plist symbol) (cddr pl)))
  148.       ((endp pl))
  149.     (unless (and (symbolp (car pl))
  150.                  (or (eq (symbol-package (car pl)) (find-package 'system))
  151.                      (eq (symbol-package (car pl)) (find-package 'compiler))))
  152.       (if *inspect-mode*
  153.           (inspect-recursively (format nil "property ~S:" (car pl))
  154.                                (cadr pl)
  155.                                (get symbol (car pl)))
  156.           (inspect-print (format nil "property ~:@(~S~):~%   ~~S" (car pl))
  157.                          (cadr pl)
  158.                          (get symbol (car pl))))))
  159.   
  160.   (when (print-doc symbol t)
  161.         (format t "~&-----------------------------------------------------------------------------~%"))
  162.   )
  163.  
  164. (defun inspect-package (package)
  165.   (format t "~S - package" package)
  166.   (when (package-nicknames package)
  167.         (inspect-print "nicknames:  ~S" (package-nicknames package)))
  168.   (when (package-use-list package)
  169.         (inspect-print "use list:  ~S" (package-use-list package)))
  170.   (when  (package-used-by-list package)
  171.          (inspect-print "used-by list:  ~S" (package-used-by-list package)))
  172.   (when (package-shadowing-symbols package)
  173.         (inspect-print "shadowing symbols:  ~S"
  174.                        (package-shadowing-symbols package))))
  175.  
  176. (defun inspect-character (character)
  177.   (format t
  178.           (cond ((standard-char-p character) "~S - standard character")
  179.                 ((string-char-p character) "~S - string character")
  180.                 (t "~S - character"))
  181.           character)
  182.   (inspect-print "code:  #x~X" (char-code character))
  183.   (inspect-print "bits:  ~D" (char-bits character))
  184.   (inspect-print "font:  ~D" (char-font character)))
  185.  
  186. (defun inspect-number (number)
  187.   (case (type-of number)
  188.     (fixnum (format t "~S - fixnum (32 bits)" number))
  189.     (bignum (format t "~S - bignum" number))
  190.     (ratio
  191.      (format t "~S - ratio" number)
  192.      (inspect-recursively "numerator:" (numerator number))
  193.      (inspect-recursively "denominator:" (denominator number)))
  194.     (complex
  195.      (format t "~S - complex" number)
  196.      (inspect-recursively "real part:" (realpart number))
  197.      (inspect-recursively "imaginary part:" (imagpart number)))
  198.     ((short-float single-float)
  199.      (format t "~S - short-float" number)
  200.      (multiple-value-bind (signif expon sign)
  201.           (integer-decode-float number)
  202.        (declare (ignore sign))
  203.        (inspect-print "exponent:  ~D" expon)
  204.        (inspect-print "mantissa:  ~D" signif)))
  205.     ((long-float double-float)
  206.      (format t "~S - long-float" number)
  207.      (multiple-value-bind (signif expon sign)
  208.           (integer-decode-float number)
  209.        (declare (ignore sign))
  210.        (inspect-print "exponent:  ~D" expon)
  211.        (inspect-print "mantissa:  ~D" signif)))))
  212.  
  213. (defun inspect-cons (cons)
  214.   (format t
  215.           (case (car cons)
  216.             ((lambda lambda-block lambda-closure lambda-block-closure)
  217.              "~S - function")
  218.             (quote "~S - constant")
  219.             (t "~S - cons"))
  220.           cons)
  221.   (when *inspect-mode*
  222.         (do ((i 0 (1+ i))
  223.              (l cons (cdr l)))
  224.             ((atom l)
  225.              (inspect-recursively (format nil "nthcdr ~D:" i)
  226.                                   l (cdr (nthcdr (1- i) cons))))
  227.           (inspect-recursively (format nil "nth ~D:" i)
  228.                                (car l) (nth i cons)))))
  229.  
  230. (defun inspect-string (string)
  231.   (format t (if (simple-string-p string) "~S - simple string" "~S - string")
  232.           string)
  233.   (inspect-print  "dimension:  ~D"(array-dimension string 0))
  234.   (when (array-has-fill-pointer-p string)
  235.         (inspect-print "fill pointer:  ~D"
  236.                        (fill-pointer string)
  237.                        (fill-pointer string)))
  238.   (when *inspect-mode*
  239.         (dotimes (i (array-dimension string 0))
  240.                  (inspect-recursively (format nil "aref ~D:" i)
  241.                                       (char string i)
  242.                                       (char string i)))))
  243.  
  244. (defun inspect-vector (vector)
  245.   (format t (if (simple-vector-p vector) "~S - simple vector" "~S - vector")
  246.           vector)
  247.   (inspect-print  "dimension:  ~D" (array-dimension vector 0))
  248.   (when (array-has-fill-pointer-p vector)
  249.         (inspect-print "fill pointer:  ~D"
  250.                        (fill-pointer vector)
  251.                        (fill-pointer vector)))
  252.   (when *inspect-mode*
  253.         (dotimes (i (array-dimension vector 0))
  254.                  (inspect-recursively (format nil "aref ~D:" i)
  255.                                       (aref vector i)
  256.                                       (aref vector i)))))
  257.  
  258. (defun inspect-array (array)
  259.   (format t (if (adjustable-array-p array)
  260.                 "~S - adjustable aray"
  261.                 "~S - array")
  262.           array)
  263.   (inspect-print "rank:  ~D" (array-rank array))
  264.   (inspect-print "dimensions:  ~D" (array-dimensions array))
  265.   (inspect-print "total size:  ~D" (array-total-size array)))
  266.  
  267. (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
  268.   (inspect-indent)
  269.   (when (and (not *inspect-mode*)
  270.              (or (> *inspect-level* 5)
  271.                  (member object *inspect-history*)))
  272.         (prin1 object)
  273.         (return-from inspect-object))
  274.   (incf *inspect-level*)
  275.   (push object *inspect-history*)
  276.   (catch 'abort-inspect
  277.          (cond ((symbolp object) (inspect-symbol object))
  278.                ((packagep object) (inspect-package object))
  279.                ((characterp object) (inspect-character object))
  280.                ((numberp object) (inspect-number object))
  281.                ((consp object) (inspect-cons object))
  282.                ((stringp object) (inspect-string object))
  283.                ((vectorp object) (inspect-vector object))
  284.                ((arrayp object) (inspect-array object))
  285.                (t (format t "~S - ~S" object (type-of object))))))
  286.  
  287.  
  288. (defun describe (object &aux (*inspect-mode* nil)
  289.                              (*inspect-level* 0)
  290.                              (*inspect-history* nil)
  291.                              (*print-level* nil)
  292.                              (*print-length* nil))
  293.   "The lisp function DESCRIBE."
  294.   (terpri)
  295.   (catch 'quit-inspect (inspect-object object))
  296.   (terpri)
  297.   (values))
  298.  
  299. (defun inspect (object &aux (*inspect-mode* t)
  300.                             (*inspect-level* 0)
  301.                             (*inspect-history* nil)
  302.                             (*old-print-level* *print-level*)
  303.                             (*old-print-length* *print-length*)
  304.                             (*print-level* 3)
  305.                             (*print-length* 3))
  306.   "The lisp function INSPECT."
  307.   (read-line)
  308.   (princ "Type ? and a newline for help.")
  309.   (terpri)
  310.   (catch 'quit-inspect (inspect-object object))
  311.   (terpri)
  312.   (values))
  313.  
  314. (defun print-doc (symbol &optional (called-from-apropos-doc-p nil)
  315.                          &aux (f nil) x)
  316.   (flet ((doc1 (doc ind)
  317.            (setq f t)
  318.            (format t
  319.                    "~&-----------------------------------------------------------------------------~%~53S~24@A~%~A"
  320.                    symbol ind doc))
  321.          (good-package ()
  322.            (if (eq (symbol-package symbol) (find-package "LISP"))
  323.                (find-package "SYSTEM")
  324.                *package*)))
  325.  
  326.     (cond ((special-form-p symbol)
  327.            (doc1 (or (documentation symbol 'function) "")
  328.                  (if (macro-function symbol)
  329.                      "[Special form and Macro]"
  330.                      "[Special form]")))
  331.           ((macro-function symbol)
  332.            (doc1 (or (documentation symbol 'function) "") "[Macro]"))
  333.           ((fboundp symbol)
  334.            (doc1
  335.             (or (documentation symbol 'function)
  336.                 (if (consp (setq x (symbol-function symbol)))
  337.                     (case (car x)
  338.                           (lambda (format nil "~%Args: ~S" (cadr x)))
  339.                           (lambda-block (format nil "~%Args: ~S" (caddr x)))
  340.                           (lambda-closure
  341.                            (format nil "~%Args: ~S" (car (cddddr x))))
  342.                           (lambda-block-closure
  343.                            (format nil "~%Args: ~S" (cadr (cddddr x))))
  344.                           (t ""))
  345.                     ""))
  346.             "[Function]"))
  347.           ((setq x (documentation symbol 'function))
  348.            (doc1 x "[Macro or Function]")))
  349.  
  350.     (cond ((constantp symbol)
  351.            (unless (and (eq (symbol-package symbol) (find-package "KEYWORD"))
  352.                         (null (documentation symbol 'variable)))
  353.              (doc1 (or (documentation symbol 'variable) "") "[Constant]")))
  354.           ((si:specialp symbol)
  355.            (doc1 (or (documentation symbol 'variable) "")
  356.                  "[Special variable]"))
  357.           ((or (setq x (documentation symbol 'variable)) (boundp symbol))
  358.            (doc1 (or x "") "[Variable]")))
  359.  
  360.     (cond ((setq x (documentation symbol 'type))
  361.            (doc1 x "[Type]"))
  362.           ((setq x (get symbol 'deftype-form))
  363.            (let ((*package* (good-package)))
  364.              (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFTYPE." x)
  365.                    "[Type]"))))
  366.  
  367.     (cond ((setq x (documentation symbol 'structure))
  368.            (doc1 x "[Structure]"))
  369.           ((setq x (get symbol 'defstruct-form))
  370.            (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSTRUCT." x)
  371.                  "[Structure]")))
  372.  
  373.     (cond ((setq x (documentation symbol 'setf))
  374.            (doc1 x "[Setf]"))
  375.           ((setq x (get symbol 'setf-update-fn))
  376.            (let ((*package* (good-package)))
  377.              (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF."
  378.                            `(defsetf ,symbol ,(get symbol 'setf-update-fn)))
  379.                    "[Setf]")))
  380.           ((setq x (get symbol 'setf-lambda))
  381.            (let ((*package* (good-package)))
  382.              (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF."
  383.                            `(defsetf ,symbol ,@(get symbol 'setf-lambda)))
  384.                    "[Setf]")))
  385.           ((setq x (get symbol 'setf-method))
  386.            (let ((*package* (good-package)))
  387.              (doc1
  388.               (format nil
  389.                 "~@[~%Defined as: ~S~%See the doc of DEFINE-SETF-METHOD.~]"
  390.                 (if (consp x)
  391.                     (case (car x)
  392.                           (lambda `(define-setf-method ,@(cdr x)))
  393.                           (lambda-block `(define-setf-method ,@(cddr x)))
  394.                           (lambda-closure `(define-setf-method ,@(cddddr x)))
  395.                           (lambda-block-closure
  396.                            `(define-setf-method ,@(cdr (cddddr x))))
  397.                           (t nil))
  398.                     nil))
  399.             "[Setf]"))))
  400.     )
  401.  
  402.   (if called-from-apropos-doc-p
  403.       f
  404.       (progn (if f
  405.                  (format t "~&-----------------------------------------------------------------------------")
  406.                  (format t "~&No documentation for ~:@(~S~)." symbol))
  407.              (values))))
  408.  
  409. (defun apropos-doc (string &optional (package 'lisp) &aux (f nil))
  410.   (setq string (string string))
  411.   (if package
  412.       (do-symbols (symbol package)
  413.         (when (substringp string (string symbol))
  414.           (setq f (or (print-doc symbol t) f))))
  415.       (do-all-symbols (symbol)
  416.         (when (substringp string (string symbol))
  417.           (setq f (or (print-doc symbol t) f)))))
  418.   (if f
  419.       (format t "~&-----------------------------------------------------------------------------")
  420.       (format t "~&No documentation for ~S in ~:[any~;~A~] package."
  421.               string package
  422.               (and package (package-name (coerce-to-package package)))))
  423.   (values))
  424.  
  425.